home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / proxy11.zip / PROXY.INI < prev    next >
Text File  |  1991-11-09  |  5KB  |  199 lines
  1. (define %compile compile)
  2. (define (%expand-macros expr)
  3.   (if (pair? expr)
  4.     (if (symbol? (car expr))
  5.       (let ((expander (get (car expr) '%syntax)))
  6.     (if expander
  7.       (expander expr)
  8.       (let ((expander (get (car expr) '%macro)))
  9.         (if expander
  10.           (%expand-macros (expander expr))
  11.           (cons (car expr) (%expand-list (cdr expr)))))))
  12.       (%expand-list expr))
  13.     expr))
  14. (define (%expand-list lyst)
  15.   (if (pair? lyst)
  16.     (cons (%expand-macros (car lyst)) (%expand-list (cdr lyst)))
  17.     lyst))
  18. (define (compile expr #!optional env)
  19.   (if (default-object? env)
  20.     (%compile (%expand-macros expr))
  21.     (%compile (%expand-macros expr) env)))
  22. (put 'macro '%macro
  23.   (lambda (form)
  24.     (list 'put
  25.       (list 'quote (cadr form))
  26.       (list 'quote '%macro)
  27.       (caddr form))))
  28. (macro syntax
  29.   (lambda (form)
  30.     #f))
  31. (macro compiler-syntax
  32.   (lambda (form)
  33.     (list 'put
  34.       (list 'quote (cadr form))
  35.       (list 'quote '%syntax)
  36.       (caddr form))))
  37. (compiler-syntax quote
  38.   (lambda (form) form))
  39. (compiler-syntax lambda
  40.   (lambda (form)
  41.     (cons
  42.       'lambda
  43.       (cons
  44.     (cadr form)
  45.     (%expand-list (cddr form))))))
  46. (compiler-syntax define
  47.   (lambda (form)
  48.     (cons
  49.       'define
  50.       (cons
  51.     (cadr form)
  52.     (%expand-list (cddr form))))))
  53. (compiler-syntax set!
  54.   (lambda (form)
  55.     (cons
  56.       'set!
  57.       (cons
  58.     (cadr form)
  59.     (%expand-list (cddr form))))))
  60. (define (%cond-expander lyst)
  61.   (cond
  62.       ((pair? lyst)
  63.        (cons
  64.      (if (pair? (car lyst))
  65.        (%expand-list (car lyst))
  66.        (car lyst))
  67.      (%cond-expander (cdr lyst))))
  68.       (else lyst)))
  69. (compiler-syntax cond
  70.   (lambda (form)
  71.     (cons 'cond (%cond-expander (cdr form)))))
  72. (define (%expand-let-assignment pair)
  73.   (if (pair? pair)
  74.     (cons
  75.       (car pair)
  76.       (%expand-macros (cdr pair)))
  77.     pair))
  78. (define (%expand-let-form form)
  79.   (cons
  80.     (car form)
  81.     (cons
  82.       (let ((lyst (cadr form)))
  83.     (if (pair? lyst)
  84.       (map %expand-let-assignment lyst)
  85.       lyst))
  86.       (%expand-list (cddr form)))))
  87. (compiler-syntax let %expand-let-form)
  88. (compiler-syntax let* %expand-let-form)
  89. (compiler-syntax letrec %expand-let-form)
  90. (macro define-integrable
  91.   (lambda (form)
  92.     (cons 'define (cdr form))))
  93. (macro declare
  94.   (lambda (form) #f))
  95. (define APPEND-ME-SYM (gensym))
  96. (define QQ-EXPANDER
  97.   (lambda (l)
  98.       (letrec
  99.        (
  100.         (qq-lev 0) ; always >= 0
  101.         (QQ-CAR-CDR
  102.          (lambda (exp)
  103.              (let ((qq-car (qq (car exp)))
  104.                (qq-cdr (qq (cdr exp))))
  105.               (if (and (pair? qq-car)
  106.                    (eq? (car qq-car) append-me-sym))
  107.                   (list 'append (cdr qq-car) qq-cdr)
  108.                   (list 'cons qq-car qq-cdr)))))
  109.         (QQ
  110.          (lambda (exp)
  111.              (cond ((symbol? exp)
  112.                 (list 'quote exp))
  113.                ((vector? exp)
  114.                 (list 'list->vector (qq (vector->list exp))))
  115.                ((atom? exp)
  116.                 exp)
  117.                ((eq? (car exp) 'quasiquote)
  118.                 (set! qq-lev (1+ qq-lev))
  119.                 (let ((qq-val
  120.                    (if (= qq-lev 1)
  121.                        (qq (cadr exp))
  122.                        (qq-car-cdr exp))))
  123.                  (set! qq-lev (-1+ qq-lev))
  124.                  qq-val))
  125.                ((or (eq? (car exp) 'unquote)
  126.                 (eq? (car exp) 'unquote-splicing))
  127.                 (set! qq-lev (-1+ qq-lev))
  128.                 (let ((qq-val
  129.                    (if (= qq-lev 0)
  130.                        (if (eq? (car exp) 'unquote-splicing)
  131.                        (cons append-me-sym
  132.                          (%expand-macros (cadr exp)))
  133.                        (%expand-macros (cadr exp)))
  134.                        (qq-car-cdr exp))))
  135.                  (set! qq-lev (1+ qq-lev))
  136.                  qq-val))
  137.                (else
  138.                 (qq-car-cdr exp)))))
  139.         )
  140.        (let ((expansion (qq l)))
  141.         (if check-qq-expansion-flag
  142.             (check-qq-expansion expansion))
  143.         expansion))))
  144. (define CHECK-QQ-EXPANSION
  145.   (lambda (exp)
  146.       (cond ((vector? exp)
  147.          (check-qq-expansion (vector->list exp)))
  148.         ((atom? exp)
  149.          #f)
  150.         (else
  151.          (if (eq? (car exp) append-me-sym)
  152.              (error "UNQUOTE-SPLICING in unspliceable position"
  153.                 (list 'unquote-splicing (cdr exp)))
  154.              (or (check-qq-expansion (car exp))
  155.              (check-qq-expansion (cdr exp))))))))
  156. (define CHECK-QQ-EXPANSION-FLAG #t)
  157. (define UNQ-EXPANDER
  158.   (lambda (l) (error "UNQUOTE outside QUASIQUOTE" l)))
  159. (define UNQ-SPL-EXPANDER
  160.   (lambda (l) (error "UNQUOTE SPLICING outside QUASIQUOTE" l)))
  161. (compiler-syntax QUASIQUOTE qq-expander)
  162. (compiler-syntax UNQUOTE unq-expander)
  163. (compiler-syntax UNQUOTE-SPLICING unq-spl-expander)
  164. (define (eval x #!optional env)
  165.   ((if (default-object? env)
  166.      (compile x)
  167.      (compile x env))))
  168. (define old-apply apply)
  169. (define (apply f . args)
  170.   (old-apply f (old-apply list* args)))
  171. (define (autoload-from-file file syms #!optional env)
  172.   (map (lambda (sym) (put sym '%autoload file)) syms)
  173.   '())
  174. (define (*unbound-handler* sym cont)
  175.   (let ((file (get sym '%autoload)))
  176.     (if file (load file))
  177.     (if (not (bound? sym))
  178.       (error "unbound variable" sym))
  179.     (cont '())))
  180. (macro case
  181.   (lambda (form)
  182.     (let ((test (cadr form))
  183.       (sym (gensym)))
  184.       `(let ((,sym ,test))
  185.      (cond ,@(map (lambda (x)
  186.             (cond ((eq? (car x) 'else)
  187.                    x)
  188.                   ((atom? (car x))
  189.                    `((eqv? ,sym ',(car x)) ,@(cdr x)))
  190.                   (else
  191.                    `((memv ,sym ',(car x)) ,@(cdr x)))))
  192.               (cddr form)))))))
  193. (define (*initialize*)
  194.   (*toplevel*))
  195. (load "proxy.s")
  196. (save "proxy.wks")
  197. (print 'loading-ended)
  198. (exit)
  199.